home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Visual Basic Graphics Programming (2nd Edition)
/
Visual Basic Graphics Programming 2nd Edition.iso
/
Src
/
Ch8
/
Bounce2b.frm
(
.txt
)
< prev
next >
Wrap
Visual Basic Form
|
1999-05-28
|
10KB
|
281 lines
VERSION 5.00
Begin VB.Form frmBounce2b
Caption = "Bounce2b"
ClientHeight = 5235
ClientLeft = 1320
ClientTop = 825
ClientWidth = 6870
LinkTopic = "Form1"
PaletteMode = 1 'UseZOrder
ScaleHeight = 349
ScaleMode = 3 'Pixel
ScaleWidth = 458
Begin VB.PictureBox picHidden
Height = 495
Index = 0
Left = 480
ScaleHeight = 435
ScaleWidth = 555
TabIndex = 6
Top = 240
Visible = 0 'False
Width = 615
End
Begin VB.TextBox txtFramesPerSecond
Height = 285
Left = 1440
TabIndex = 4
Text = "20"
Top = 4920
Width = 375
End
Begin VB.TextBox txtNumBalls
Height = 285
Left = 1440
TabIndex = 3
Text = "20"
Top = 4560
Width = 375
End
Begin VB.CommandButton cmdStart
Caption = "Start"
Default = -1 'True
Height = 495
Left = 2160
TabIndex = 1
Top = 4620
Width = 855
End
Begin VB.PictureBox picCourt
AutoRedraw = -1 'True
Height = 4455
Left = 0
ScaleHeight = 293
ScaleMode = 3 'Pixel
ScaleWidth = 453
TabIndex = 0
Top = 0
Width = 6855
End
Begin VB.Label Label1
Caption = "Frames per second:"
Height = 255
Index = 0
Left = 0
TabIndex = 5
Top = 4920
Width = 1455
End
Begin VB.Label Label1
Caption = "Number of balls:"
Height = 255
Index = 1
Left = 0
TabIndex = 2
Top = 4560
Width = 1455
End
Attribute VB_Name = "frmBounce2b"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private xmax As Integer
Private ymax As Integer
Private NumBalls As Integer
Private BallX() As Integer
Private BallY() As Integer
Private BallDx() As Integer
Private BallDy() As Integer
Private BallRadius() As Integer
Private BallColor() As Long
Private Playing As Boolean
Private NumPlayed As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
' Draw some random rectangles on the bacground.
Private Sub DrawBackground()
Dim i As Integer
Dim wid As Single
Dim hgt As Single
' Start with a clean slate.
picCourt.Line (0, 0)-(picCourt.ScaleWidth, picCourt.ScaleHeight), picCourt.BackColor, BF
' Draw some rectangles.
For i = 1 To 10
hgt = 10 + Rnd * xmax / 3
wid = 10 + Rnd * ymax / 3
picCourt.Line (Int(Rnd * xmax), Int(Rnd * ymax))-Step(hgt, wid), QBColor(Int(Rnd * 16)), BF
Next i
' Make the rectangles part of the permanent background.
picCourt.Picture = picCourt.Image
End Sub
' Generate some random data.
Private Sub InitData()
Dim ball As Integer
Dim R As Integer
Dim clr As Integer
' See how many balls there should be.
If Not IsNumeric(txtNumBalls.Text) Then _
txtNumBalls.Text = "10"
NumBalls = CInt(txtNumBalls.Text)
ReDim BallRadius(1 To NumBalls)
ReDim BallX(1 To NumBalls)
ReDim BallY(1 To NumBalls)
ReDim BallDx(1 To NumBalls)
ReDim BallDy(1 To NumBalls)
ReDim BallColor(1 To NumBalls)
' Set the initial ball data.
For ball = 1 To NumBalls
R = Int(10 * Rnd + 5)
BallRadius(ball) = R
BallX(ball) = Int((xmax - R + 1) * Rnd)
BallY(ball) = Int((ymax - R + 1) * Rnd)
BallDx(ball) = Int(21 * Rnd - 10)
BallDy(ball) = Int(21 * Rnd - 10)
clr = Int(15 * Rnd)
If clr >= 7 Then clr = clr + 1
BallColor(ball) = QBColor(clr)
' Create a hidden PictureBox for this ball.
If ball > picHidden.UBound Then
Load picHidden(ball)
End If
' Make the picture big enough.
picHidden(ball).Width = 2 * BallRadius(ball) + 4
picHidden(ball).Height = 2 * BallRadius(ball) + 4
Next ball
' Unload any hidden PictureBoxes we no longer need.
For ball = NumBalls + 1 To picHidden.UBound
Unload picHidden(ball)
Next ball
End Sub
' Start the animation.
Private Sub cmdStart_Click()
If Playing Then
Playing = False
cmdStart.Caption = "Stopped"
cmdStart.Enabled = False
Else
cmdStart.Caption = "Stop"
Playing = True
InitData
PlayData
Playing = False
cmdStart.Caption = "Start"
cmdStart.Enabled = True
End If
End Sub
' Play the animation.
Private Sub PlayData()
Dim ms_per_frame As Long
Dim start_time As Single
Dim stop_time As Single
' Draw a random background.
DrawBackground
' See how fast we should go.
If Not IsNumeric(txtFramesPerSecond.Text) Then _
txtFramesPerSecond.Text = "10"
ms_per_frame = 1000 \ CLng(txtFramesPerSecond.Text)
' Start the animation.
NumPlayed = 0
start_time = Timer
PlayImages ms_per_frame
' Display results.
stop_time = Timer
MsgBox "Displayed" & Str$(NumPlayed) & _
" frames in " & _
Format$(stop_time - start_time, "0.00") & _
" seconds (" & _
Format$(NumPlayed / (stop_time - start_time), "0.00") & _
" FPS)."
End Sub
' Play the animation.
Private Sub PlayImages(ByVal ms_per_frame As Long)
Dim ball As Integer
Dim next_time As Long
' Get the current time.
next_time = GetTickCount()
' Start the animation.
Do While Playing
NumPlayed = NumPlayed + 1
' Save the background where the balls
' will be placed.
For ball = 1 To NumBalls
BitBlt picHidden(ball).hDC, _
0, 0, _
2 * BallRadius(ball) + 4, _
2 * BallRadius(ball) + 4, _
picCourt.hDC, _
BallX(ball) - BallRadius(ball) - 2, _
BallY(ball) - BallRadius(ball) - 2, _
vbSrcCopy
picHidden(ball).Picture = picHidden(ball).Image
Next ball
' Draw the balls.
For ball = 1 To NumBalls
picCourt.FillColor = BallColor(ball)
picCourt.Circle _
(BallX(ball), BallY(ball)), _
BallRadius(ball), BallColor(ball)
Next ball
' Wait until it's time for the next frame.
next_time = next_time + ms_per_frame
WaitTill next_time
' Restore the background information.
For ball = 1 To NumBalls
BitBlt picCourt.hDC, _
BallX(ball) - BallRadius(ball) - 2, _
BallY(ball) - BallRadius(ball) - 2, _
2 * BallRadius(ball) + 4, _
2 * BallRadius(ball) + 4, _
picHidden(ball).hDC, _
0, 0, _
vbSrcCopy
Next ball
' Move the balls for the next frame,
' keeping them within picCourt.
For ball = 1 To NumBalls
BallX(ball) = BallX(ball) + BallDx(ball)
If BallX(ball) < BallRadius(ball) Then
BallX(ball) = 2 * BallRadius(ball) - BallX(ball)
BallDx(ball) = -BallDx(ball)
ElseIf BallX(ball) > xmax - BallRadius(ball) Then
BallX(ball) = 2 * (xmax - BallRadius(ball)) - BallX(ball)
BallDx(ball) = -BallDx(ball)
End If
BallY(ball) = BallY(ball) + BallDy(ball)
If BallY(ball) < BallRadius(ball) Then
BallY(ball) = 2 * BallRadius(ball) - BallY(ball)
BallDy(ball) = -BallDy(ball)
ElseIf BallY(ball) > ymax - BallRadius(ball) Then
BallY(ball) = 2 * (ymax - BallRadius(ball)) - BallY(ball)
BallDy(ball) = -BallDy(ball)
End If
Next ball
If Not Playing Then Exit Do
Loop
End Sub
Private Sub Form_Load()
Randomize
picCourt.FillStyle = vbSolid
picCourt.ScaleMode = vbPixels
With picHidden(0)
.AutoRedraw = True
.Visible = False
.ScaleMode = vbPixels
.BorderStyle = vbBSNone
End With
End Sub
' Make the ball court nice and big.
Private Sub Form_Resize()
Const GAP = 3
txtFramesPerSecond.Top = ScaleHeight - GAP - txtFramesPerSecond.Height
Label1(0).Top = txtFramesPerSecond.Top
txtNumBalls.Top = txtFramesPerSecond.Top - GAP - txtNumBalls.Height
Label1(1).Top = txtNumBalls.Top
cmdStart.Top = (txtNumBalls.Top + txtFramesPerSecond.Top + txtFramesPerSecond.Height - cmdStart.Height) / 2
picCourt.Move 0, 0, ScaleWidth, txtNumBalls.Top - GAP
xmax = picCourt.ScaleWidth - 1
ymax = picCourt.ScaleHeight - 1
picCourt.Picture = picCourt.Image
End Sub